home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / cmpnew / cmpenv.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  23KB  |  572 lines
  1. ;;; CMPENV  Environments of the Compiler.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (defvar *safe-compile* nil)
  10. (defvar *compiler-check-args* nil)
  11. (defvar *compiler-push-events* nil)
  12. (defvar *speed* 3)
  13. (defvar *space* 0)
  14.  
  15. ;;; Only these flags are set by the user.
  16. ;;; If *safe-compile* is ON, some kind of run-time checks are not
  17. ;;; included in the compiled code.  The default value is OFF.
  18.  
  19. (defun init-env ()
  20.   (setq *next-cvar* 0)
  21.   (setq *next-cmacro* 0)
  22.   (setq *next-vv* -1)
  23.   (setq *next-cfun* 0)
  24.   (setq *last-label* 0)
  25.   (setq *objects* nil)
  26.   (setq *constants* nil)
  27.   (setq *local-funs* nil)
  28.   (setq *global-funs* nil)
  29.   (setq *global-entries* nil)
  30.   (setq *undefined-vars* nil)
  31.   (setq *reservations* nil)
  32.   (setq *closures* nil)
  33.   (setq *top-level-forms* nil)
  34.   (setq *compile-time-too* *eval-when-compile*)
  35.   (setq *non-package-operation* nil)
  36.   (setq *function-declarations* nil)
  37.   (setq *inline-functions* nil)
  38.   (setq *inline-blocks* 0)
  39.   (setq *notinline* nil)
  40.   )
  41.  
  42. (defvar *next-cvar* 0)
  43. (defvar *next-cmacro* 0)
  44. (defvar *next-vv* -1)
  45. (defvar *next-cfun* 0)
  46.  
  47. ;;; *next-cvar* holds the last cvar number used.
  48. ;;; *next-cmacro* holds the last cmacro number used.
  49. ;;; *next-vv* holds the last VV index used.
  50. ;;; *next-cfun* holds the last cfun used.
  51.  
  52. (defmacro next-cfun () '(incf *next-cfun*))
  53.  
  54. (defun add-symbol (symbol)
  55.   (let ((x (assoc symbol *objects*)))
  56.        (cond (x (cadr x))
  57.              (t (incf *next-vv*)
  58.                 (push (list symbol *next-vv*) *objects*)
  59.                 (wt-data symbol)
  60.                 *next-vv*))))
  61.  
  62. (defun add-object (object &aux x)
  63.   ;;; Used only during Pass 1.
  64.   (cond ((si:contains-sharp-comma object)
  65.          ;;; SI:CONTAINS-SHARP-COMMA returns T iff OBJECT
  66.          ;;; contains a sharp comma OR a structure.
  67.          (incf *next-vv*)
  68.          (push *next-vv* *sharp-commas*)
  69.          (wt-data (prin1-to-string object))
  70.          *next-vv*)
  71.         ((setq x (assoc object *objects*))
  72.          (cadr x))
  73.         (t (incf *next-vv*)
  74.            (push (list object *next-vv*) *objects*)
  75.            (wt-data object)
  76.            *next-vv*)))
  77.  
  78. (defun add-constant (symbol &aux x)
  79.   ;;; Used only during Pass 1.
  80.   (cond ((setq x (assoc symbol *constants*))
  81.          (cadr x))
  82.         (t (incf *next-vv*)
  83.            (push *next-vv* *sharp-commas*)
  84.            (wt-data (prin1-to-string (cons 'si:|#,| symbol)))
  85.            (push (list symbol *next-vv*) *constants*)
  86.            *next-vv*)))
  87.  
  88. (defmacro next-cvar () '(incf *next-cvar*))
  89. (defmacro next-cmacro () '(incf *next-cmacro*))
  90.  
  91. ;;; Tail recursion information.
  92. (defvar *do-tail-recursion* t)
  93. (defvar *tail-recursion-info* nil)
  94. ;;; Tail recursion optimization never occurs if *do-tail-recursion* is NIL.
  95. ;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
  96. ;;; If possible, *tail-recursion-info* holds
  97. ;;;    ( fname  required-arg .... required-arg ),
  98. ;;; where each required-arg is a var-object.
  99.  
  100.  
  101. (defvar *function-declarations* nil)
  102. ;;; *function-declarations* holds :
  103. ;;;    (... ( { function-name | fun-object } arg-types return-type ) ...)
  104. ;;; Function declarations for global functions are ASSOCed by function names,
  105. ;;; whereas those for local functions are ASSOCed by function objects.
  106. ;;;
  107. ;;; The valid argment type declaration is:
  108. ;;;    ( {type}* [ &optional {type}* ] [ &rest type ] [ &key {type}* ] )
  109. ;;; though &optional, &rest, and &key return types are simply ignored.
  110.  
  111. (defun function-arg-types (arg-types &aux (types nil))
  112.   (do ((al arg-types (cdr al)))
  113.       ((or (endp al)
  114.            (member (car al) '(&optional &rest &key)))
  115.        (reverse types))
  116.       (declare (object al))
  117.       (push (type-filter (car al)) types)))
  118.  
  119. ;;; The valid return type declaration is:
  120. ;;;    (( VALUES {type}* )) or ( {type}* ).
  121.  
  122. (defun function-return-type (return-types)
  123.   (cond ((endp return-types) t)
  124.         ((and (consp (car return-types))
  125.               (eq (caar return-types) 'values))
  126.          (cond ((not (endp (cdr return-types)))
  127.                 (warn "The function return types ~s is illegal." return-types)
  128.                 t)
  129.                ((or (endp (cdar return-types))
  130.                     (member (cadar return-types) '(&optional &rest &key)))
  131.                 t)
  132.                (t (type-filter (cadar return-types)))))
  133.         (t (type-filter (car return-types)))))
  134.  
  135. (defun add-function-proclamation (fname arg-types return-types)
  136.   (cond ((symbolp fname)
  137.          (si:putprop fname (function-arg-types arg-types)
  138.                      'proclaimed-arg-types)
  139.          (si:putprop fname (function-return-type return-types)
  140.                      'proclaimed-return-type)
  141.          ;;; A non-local function may have local entry only if it returns
  142.          ;;; a single value.
  143.          (if (and (not (endp return-types))
  144.                   (endp (cdr return-types))
  145.                   (not (and (consp (car return-types))
  146.                             (eq (caar return-types) 'values)
  147.                             (or (endp (cdar return-types))
  148.                                 (not (endp (cddar return-types)))))))
  149.              (si:putprop fname t 'proclaimed-function)
  150.              (remprop fname 'proclaimed-function)))
  151.         (t (warn "The function name ~s is not a symbol." fname))))
  152.  
  153. (defun add-function-declaration (fname arg-types return-types)
  154.   (cond ((symbolp fname)
  155.          (push (list (sch-local-fun fname)
  156.                      (function-arg-types arg-types)
  157.                      (function-return-type return-types))
  158.                *function-declarations*))
  159.         (t (warn "The function name ~s is not a symbol." fname))))
  160.  
  161. (defun get-arg-types (fname &aux x)
  162.   (if (setq x (assoc fname *function-declarations*))
  163.       (cadr x)
  164.       (get fname 'proclaimed-arg-types)))
  165.  
  166. (defun get-return-type (fname)
  167.   (let* ((x (assoc fname *function-declarations*))
  168.          (type1 (if x (caddr x) (get fname 'proclaimed-return-type))))
  169.         (cond (type1
  170.                (let ((type (get fname 'return-type)))
  171.                     (cond (type
  172.                            (cond ((setq type (type-and type type1)) type)
  173.                                  (t
  174.                                   (cmpwarn
  175.                                    "The return type of ~s was badly declared."
  176.                                    fname))))
  177.                           (t type1))))
  178.               (t (get fname 'return-type)))
  179.         ))
  180.  
  181. (defun get-local-arg-types (fun &aux x)
  182.   (if (setq x (assoc fun *function-declarations*))
  183.       (cadr x)
  184.       nil))
  185.  
  186. (defun get-local-return-type (fun &aux x)
  187.   (if (setq x (assoc fun *function-declarations*))
  188.       (caddr x)
  189.       nil))
  190.  
  191. (defvar *sup-used* nil)
  192. (defvar *base-used* nil)
  193.  
  194. (defun reset-top ()
  195.        (wt "vs_top=sup;")
  196.        (setq *sup-used* t))
  197.  
  198. (defmacro base-used () '(setq *base-used* t))
  199.  
  200. ;;; Proclamation and declaration handling.
  201.  
  202. (defvar *alien-declarations* nil)
  203. (defvar *notinline* nil)
  204.  
  205. (defun inline-possible (fname)
  206.        (not (or *compiler-push-events*
  207.                 (member fname *notinline*)
  208.                 (get fname 'cmp-notinline))))
  209.  
  210. (defun proclaim (decl)
  211.   (case (car decl)
  212.     (special
  213.      (dolist** (var (cdr decl))
  214.        (if (symbolp var)
  215.            (si:*make-special var)
  216.            (warn "The variable name ~s is not a symbol." var))))
  217.     (optimize
  218.      (dolist (x (cdr decl))
  219.        (when (symbolp x) (setq x (list x 3)))
  220.        (if (or (not (consp x))
  221.                (not (consp (cdr x)))
  222.                (not (numberp (cadr x)))
  223.                (not (<= 0 (cadr x) 3)))
  224.            (warn "The OPTIMIZE proclamation ~s is illegal." x)
  225.            (case (car x)
  226.                  (safety (setq *compiler-check-args* (>= (cadr x) 1))
  227.                          (setq *safe-compile* (>= (cadr x) 2))
  228.                          (setq *compiler-push-events* (>= (cadr x) 3)))
  229.                  (space (setq *space* (cadr x)))
  230.                  (speed (setq *speed* (cadr x)))
  231.                  (compilation-speed (setq *speed* (- 3 (cadr x))))
  232.                  (t (warn "The OPTIMIZE quality ~s is unknown." (car x)))))))
  233.     (type
  234.      (if (consp (cdr decl))
  235.          (proclaim-var (cadr decl) (cddr decl))
  236.          (warn "The type declaration ~s is illegal." decl)))
  237.     ((fixnum character short-float long-float)
  238.      (proclaim-var (car decl) (cdr decl)))
  239.     (ftype
  240.      (if (or (endp (cdr decl))
  241.              (not (consp (cadr decl)))
  242.              (not (eq (caadr decl) 'function))
  243.              (endp (cdadr decl)))
  244.          (warn "The function declaration ~s is illegal." decl)
  245.          (dolist** (fname (cddr decl))
  246.            (add-function-proclamation fname (cadadr decl) (cddadr decl)))))
  247.     (function
  248.      (if (or (endp (cdr decl)) (endp (cddr decl)))
  249.          (warn "The function declaration ~s is illegal." decl)
  250.          (add-function-proclamation (cadr decl) (caddr decl) (cdddr decl))))
  251.     (inline
  252.      (dolist** (fun (cdr decl))
  253.                (if (symbolp fun)
  254.                    (remprop fun 'cmp-notinline)
  255.                    (warn "The function name ~s is not a symbol." fun))))
  256.     (notinline
  257.      (dolist** (fun (cdr decl))
  258.                (if (symbolp fun)
  259.                    (si:putprop fun t 'cmp-notinline)
  260.                    (warn "The function name ~s is not a symbol." fun))))
  261.     ((object ignore)
  262.      (dolist** (var (cdr decl))
  263.        (unless (symbolp var)
  264.                (warn "The variable name ~s is not a symbol." var))))
  265.     (declaration
  266.      (dolist** (x (cdr decl))
  267.        (if (symbolp x)
  268.            (unless (member x *alien-declarations*)
  269.                    (push x *alien-declarations*))
  270.            (warn "The declaration specifier ~s is not a symbol." x))))
  271.     ((array atom bignum bit bit-vector character common compiled-function
  272.       complex cons double-float fixnum float hash-table integer keyword list
  273.       long-float nil null number package pathname random-state ratio rational
  274.       readtable sequence short-float simple-array simple-bit-vector
  275.       simple-string simple-vector single-float standard-char stream string
  276.       string-char symbol t vector signed-byte unsigned-byte)
  277.      (proclaim-var (car decl) (cdr decl)))
  278.     (otherwise
  279.      (unless (member (car decl) *alien-declarations*)
  280.              (warn "The declaration specifier ~s is unknown." (car decl))))
  281.     )
  282.   nil
  283.   )
  284.  
  285. (defun proclaim-var (type vl)
  286.   (setq type (type-filter type))
  287.   (dolist** (var vl)
  288.     (cond ((symbolp var)
  289.            (let ((type1 (get var 'cmp-type))
  290.                  (v (sch-global var)))
  291.                 (setq type1 (if type1 (type-and type1 type) type))
  292.                 (when v (setq type1 (type-and type1 (var-type v))))
  293.                 (when (null type1) (warn
  294.       "Inconsistent type declaration was found for the variable ~s."
  295.                                     var))
  296.                 (si:putprop var type1 'cmp-type)
  297.                 (when v (setf (var-type v) type1))))
  298.           (t
  299.            (warn "The variable name ~s is not a symbol." var)))))
  300.  
  301. (defun c1body (body doc-p &aux (ss nil) (is nil) (ts nil) (others nil)
  302.                     doc form)
  303.   (loop
  304.     (when (endp body) (return))
  305.     (setq form (cmp-macroexpand (car body)))
  306.     (cond
  307.      ((stringp form)
  308.       (when (or (null doc-p) (endp (cdr body)) doc) (return))
  309.       (setq doc form))
  310.      ((and (consp form) (eq (car form) 'declare))
  311.       (dolist** (decl (cdr form))
  312.         (cmpck (or (not (consp decl)) (not (symbolp (car decl))))
  313.                "The declaration ~s is illegal." decl)
  314.         (case (car decl)
  315.           (special
  316.            (dolist** (var (cdr decl))
  317.              (cmpck (not (symbolp var))
  318.                     "The special declaration ~s contains a non-symbol ~s."
  319.                     decl var)
  320.              (push var ss)))
  321.           (ignore
  322.            (dolist** (var (cdr decl))
  323.              (cmpck (not (symbolp var))
  324.                     "The ignore declaration ~s contains a non-symbol ~s."
  325.                     decl var)
  326.              (push var is)))
  327.           (type
  328.            (cmpck (endp (cdr decl))
  329.                   "The type declaration ~s is illegal." decl)
  330.            (let ((type (type-filter (cadr decl))))
  331.                 (when type
  332.                       (dolist** (var (cddr decl))
  333.                         (cmpck (not (symbolp var))
  334.                           "The type declaration ~s contains a non-symbol ~s."
  335.                           decl var)
  336.                         (push (cons var type) ts)))))
  337.           (object
  338.            (dolist** (var (cdr decl))
  339.              (cmpck (not (symbolp var))
  340.                     "The object declaration ~s contains a non-symbol ~s."
  341.                     decl var)
  342.              (push (cons var 'object) ts)))
  343.           ((fixnum character double-float short-float array atom bignum bit
  344.             bit-vector common compiled-function complex cons float hash-table
  345.             integer keyword list long-float nil null number package pathname
  346.             random-state ratio rational readtable sequence simple-array
  347.             simple-bit-vector simple-string simple-vector single-float
  348.             standard-char stream string string-char symbol t vector
  349.             signed-byte unsigned-byte)
  350.            (let ((type (type-filter (car decl))))
  351.                 (when type
  352.                       (dolist** (var (cdr decl))
  353.                         (cmpck (not (symbolp var))
  354.                           "The type declaration ~s contains a non-symbol ~s."
  355.                           decl var)
  356.                         (push (cons var type) ts)))))
  357.           (otherwise (push decl others))
  358.           )))
  359.      (t (return)))
  360.     (pop body)
  361.     )
  362.   (values body ss ts is others doc)
  363.   )
  364.  
  365. (defun c1decl-body (decls body &aux (dl nil))
  366.   (if (null decls)
  367.       (c1progn body)
  368.       (let ((*function-declarations* *function-declarations*)
  369.             (*alien-declarations* *alien-declarations*)
  370.             (*notinline* *notinline*)
  371.             (*space* *space*))
  372.            (dolist** (decl decls dl)
  373.              (case (car decl)
  374.               (optimize
  375.                (dolist (x (cdr decl))
  376.                  (when (symbolp x) (setq x (list x 3)))
  377.                  (if (or (not (consp x))
  378.                          (not (consp (cdr x)))
  379.                          (not (numberp (cadr x)))
  380.                          (not (<= 0 (cadr x) 3)))
  381.                      (warn "The OPTIMIZE proclamation ~s is illegal." x)
  382.                      (case (car x)
  383.                            (safety (push (list 'safety (cadr x)) dl))
  384.                            (space (setq *space* (cadr x))
  385.                                   (push (list 'space (cadr x)) dl))
  386.                            ((speed compilation-speed))
  387.                            (t (warn "The OPTIMIZE quality ~s is unknown."
  388.                                     (car x)))))))
  389.               (ftype
  390.                (if (or (endp (cdr decl))
  391.                        (not (consp (cadr decl)))
  392.                        (not (eq (caadr decl) 'function))
  393.                        (endp (cdadr decl)))
  394.                    (warn "The function declaration ~s is illegal." decl)
  395.                    (dolist** (fname (cddr decl))
  396.                      (add-function-declaration
  397.                       fname (cadadr decl) (cddadr decl)))))
  398.               (function
  399.                (if (or (endp (cdr decl))
  400.                        (endp (cddr decl))
  401.                        (not (symbolp (cadr decl))))
  402.                    (warn "The function declaration ~s is illegal." decl)
  403.                    (add-function-declaration
  404.                     (cadr decl) (caddr decl) (cdddr decl))))
  405.               (inline
  406.                (dolist** (fun (cdr decl))
  407.                  (if (symbolp fun)
  408.                      (progn (push (list 'inline fun) dl)
  409.                             (setq *notinline* (remove fun *notinline*)))
  410.                      (warn "The function name ~s is not a symbol." fun))))
  411.               (notinline
  412.                (dolist** (fun (cdr decl))
  413.                  (if (symbolp fun)
  414.                      (progn (push (list 'notinline fun) dl)
  415.                             (push fun *notinline*))
  416.                      (warn "The function name ~s is not a symbol." fun))))
  417.               (declaration
  418.                (dolist** (x (cdr decl))
  419.                  (if (symbolp x)
  420.                      (unless (member x *alien-declarations*)
  421.                              (push x *alien-declarations*))
  422.                      (warn "The declaration specifier ~s is not a symbol."
  423.                            x))))
  424.               (otherwise
  425.                (unless (member (car decl) *alien-declarations*)
  426.                  (warn "The declaration specifier ~s is unknown."
  427.                        (car decl))))
  428.               ))
  429.            (setq body (c1progn body))
  430.            (list 'decl-body (cadr body) dl body)
  431.            )
  432.       )
  433.   )
  434.  
  435. (si:putprop 'decl-body 'c2decl-body 'c2)
  436.  
  437. (defun c2decl-body (decls body)
  438.   (let ((*compiler-check-args* *compiler-check-args*)
  439.         (*safe-compile* *safe-compile*)
  440.         (*compiler-push-events* *compiler-push-events*)
  441.         (*notinline* *notinline*)
  442.         (*space* *space*))
  443.        (dolist** (decl decls)
  444.          (case (car decl)
  445.                (safety
  446.                 (let ((level (cadr decl)))
  447.                      (declare (fixnum level))
  448.                      (setq *compiler-check-args* (>= level 1)
  449.                            *safe-compile* (>= level 2)
  450.                            *compiler-push-events* (>= level 3))))
  451.                (space (setq *space* (cadr decl)))
  452.                (notinline (push (cadr decl) *notinline*))
  453.                (inline
  454.                 (setq *notinline* (remove (cadr decl) *notinline*)))
  455.                (otherwise (baboon))))
  456.        (c2expr body))
  457.   )
  458.  
  459. (defun check-vdecl (vnames ts is)
  460.   (dolist** (x ts)
  461.     (unless (member (car x) vnames)
  462.       (cmpwarn "Type declaration was found for not bound variable ~s."
  463.                (car x))))
  464.   (dolist** (x is)
  465.     (unless (member x vnames)
  466.       (cmpwarn "Ignore declaration was found for not bound variable ~s." x)))
  467.   )
  468.  
  469. (defun proclamation (decl)
  470.   (case (car decl)
  471.     (special
  472.      (dolist** (var (cdr decl) t)
  473.        (if (symbolp var)
  474.            (unless (si:specialp var) (return nil))
  475.            (warn "The variable name ~s is not a symbol." var))))
  476.     (optimize
  477.      (dolist (x (cdr decl) t)
  478.        (when (symbolp x) (setq x (list x 3)))
  479.        (if (or (not (consp x))
  480.                (not (consp (cdr x)))
  481.                (not (numberp (cadr x)))
  482.                (not (<= 0 (cadr x) 3)))
  483.            (warn "The OPTIMIZE proclamation ~s is illegal." x)
  484.            (case (car x)
  485.                  (safety
  486.                   (unless (= (cadr x)
  487.                              (cond ((null *compiler-check-args*) 0)
  488.                                    ((null *safe-compile*) 1)
  489.                                    ((null *compiler-push-events*) 2)
  490.                                    (t 3)))
  491.                           (return nil)))
  492.                  (space (unless (= (cadr x) *space*) (return nil)))
  493.                  (speed (unless (= (cadr x) *speed*) (return nil)))
  494.                  (compilation-speed
  495.                   (unless (= (- 3 (cadr x)) *speed*) (return nil)))
  496.                  (t (warn "The OPTIMIZE quality ~s is unknown."
  497.                           (car x)))))))
  498.     (type
  499.      (if (consp (cdr decl))
  500.          (let ((type (type-filter (cadr decl)))
  501.                x)
  502.               (dolist** (var (cddr decl) t)
  503.                 (if (symbolp var)
  504.                     (unless (and (setq x (get var 'cmp-type))
  505.                                  (equal x type))
  506.                             (return nil))
  507.                     (warn "The variable name ~s is not a symbol." var))))
  508.          (warn "The type declaration ~s is illegal." decl)))
  509.     ((fixnum character short-float long-float)
  510.      (let ((type (type-filter (car decl)))
  511.            x)
  512.           (dolist** (var (cdr decl) t)
  513.             (if (symbolp var)
  514.                 (unless (and (setq x (get var 'cmp-type)) (equal x type))
  515.                         (return nil))
  516.                 (warn "The variable name ~s is not a symbol." var)))))
  517.     (ftype
  518.      (if (or (endp (cdr decl))
  519.              (not (consp (cadr decl)))
  520.              (not (eq (caadr decl) 'function))
  521.              (endp (cdadr decl)))
  522.          (warn "The function declaration ~s is illegal." decl)
  523.          (dolist** (fname (cddr decl) t)
  524.            (unless (and (get fname 'proclaimed-function)
  525.                         (equal (function-arg-types (cadadr decl))
  526.                                (get fname 'proclaimed-arg-types))
  527.                         (equal (function-return-type (cddadr decl))
  528.                                (get fname 'proclaimed-return-type)))
  529.                    (return nil)))))
  530.     (function
  531.      (if (or (endp (cdr decl)) (endp (cddr decl)))
  532.          (warn "The function declaration ~s is illegal." decl)
  533.          (and (get (cadr decl) 'proclaimed-function)
  534.               (equal (function-arg-types (caddr decl))
  535.                      (get (cadr decl) 'proclaimed-arg-types))
  536.               (equal (function-return-type (cdddr decl))
  537.                      (get (cadr decl) 'proclaimed-return-type)))))
  538.     (inline (dolist** (fun (cdr decl) t)
  539.               (if (symbolp fun)
  540.                   (when (get fun 'cmp-notinline) (return nil))
  541.                   (warn "The function name ~s is not a symbol." fun))))
  542.     (notinline (dolist** (fun (cdr decl) t)
  543.                  (if (symbolp fun)
  544.                      (unless (get fun 'cmp-notinline) (return nil))
  545.                      (warn "The function name ~s is not a symbol." fun))))
  546.     ((object ignore)
  547.      (dolist** (var (cdr decl) t)
  548.                (unless (symbolp var)
  549.                        (warn "The variable name ~s is not a symbol." var))))
  550.     (declaration (dolist** (x (cdr decl) t)
  551.                    (if (symbolp x)
  552.                        (unless (member x *alien-declarations*) (return nil))
  553.                        (warn "The declaration specifier ~s is not a symbol."
  554.                              x))))
  555.     ((array atom bignum bit bit-vector character common compiled-function
  556.       complex cons double-float fixnum float hash-table integer keyword list
  557.       long-float nil null number package pathname random-state ratio rational
  558.       readtable sequence short-float simple-array simple-bit-vector
  559.       simple-string simple-vector single-float standard-char stream string
  560.       string-char symbol t vector signed-byte unsigned-byte)
  561.      (let ((type (type-filter (car decl))))
  562.           (dolist** (var (cdr decl) t)
  563.             (if (symbolp var)
  564.                 (unless (equal (get var 'cmp-type) type) (return nil))
  565.                 (warn "The variable name ~s is not a symbol." var)))))
  566.     (otherwise
  567.      (unless (member (car decl) *alien-declarations*)
  568.              (warn "The declaration specifier ~s is unknown." (car decl))))
  569.     )
  570.   )
  571.  
  572.